perm filename FILLX.F4[1,LCS] blob
sn#093931 filedate 1974-03-27 generic text, type T, neo UTF8
00100 IMPLICIT INTEGER(A-Z)
00150 REAL HT,DIS,Y,HX,DX,B,H
00200 COMMON Q(100),R(100),E(100),NN
00210 COMMON/LL/L
00300 DATA Q/24,50,0,24,24,42,8,24,24,32,16,24,88*0/
00400 1,R/30,0,0,30,24,4,4,24,16,8,8,16,88*0/
00500 1,E/-1,0,0,0,-1,0,0,0,-1,91*0/,TOT/12/
00600
00700 15 NN=0
01410 200 FORMAT(A5)
01420 201 FORMAT(10I)
01430 202 FORMAT(' TYPE FILE NAME '$)
01435 TYPE 202
01440 ACCEPT 200,NM
01450 CALL IFILE(1,NM)
01452 READ(1,201)K,K
01455 J=1
01460 204 READ(1,201,END=203)K,L,(Q(K),K=J,J+L-1)
01470 J=J+L
01480 GO TO 204
01485 203 TOT=Q(1)-1
01487 Z=5
01490 206 DO 205 K=1,J-2
01500 CALL UNPACK(K+1,M,N,Q)
01510 E(K)=0
01520 IF(L.EQ.3)E(K)=-1
01530 Q(K)=M*Z
01540 205 R(K)=N*Z
01690 400 DO 40 K=1,TOT
01695 J=2
01700 IF(E(K))J=3
01800 40 CALL LINES(Q(K),R(K),J)
01810 DO 41 K=2,TOT
01820 41 IF(Q(K).EQ.Q(K-1))E(K)=-1
01900 N=1
02000 4 J=0
02010 CALL DPYOUT(1)
02100 H=-1000
02200 Z=0
02300 DO 1 K=2,TOT
02400 IF(E(K).NE.0)GO TO 1
02500 A=R(K)+500
02600 B=R(K-1)+500
02700 IF(B.GT.A)GO TO 21
02800 C=A*1000+B
02900 GO TO 20
03000 21 C=B*1000+A
03100 20 IF(C.LE.Z)GO TO 1
03200 Z=C
03300 C FINDS HIGHEST LINE
03400 J=K
03500 H=R(J)
03600 1 CONTINUE
03700
03800 IF(J.EQ.0)GO TO 10
04000 JA=J-1
04100 C J = END OF HIGHEST LINE
04200 19 RT=Q(J)
04300 LF=Q(JA)
04400 RJ=R(J)
04500 RJ1=R(JA)
04600 16 E(J)=-1
04700 C LINE USED
04800 HT=RJ-RJ1
04900 DIS=RT-LF
05000 M=1
05100 IF(DIS)M=-M
05110 X=-1
05155 J=3
05200
05300 17 DO 2 K=LF,RT,M
05500 Y=(HT*(K-LF))/DIS+RJ1
05610 IF(X)CALL LINES(K,IFIX(Y),J)
05620 J=2
05700 H=-1000
05800
05900 18 DO 3 I=2,TOT
06000 IF(E(I))GO TO 3
06100 C SKIP IF SAME LINE.
06200 QA=Q(I)
06300 QB=Q(I-1)
06400 IF((QA.GT.K.AND.QB.GT.K).OR.(QA.LT.K.AND.QB.LT.K))GOTO 3
06500 C LINE WAS NOT UNDER POINT K
06600 RA=R(I)
06700 RB=R(I-1)
06800 HX=RA-RB
06900 DX=QA-QB
07000 B=(HX*(K-QB))/DX+RB
07100 IF(B.GT.Y)GO TO 3
07200 IF(B.LE.H)GO TO 3
07210 CC IF((K.EQ.QA.OR.K.EQ.QB).AND.B.NE.Y)GO TO 3
07300 H=B
07400 IX=I
07500 C FOUND HIGHEST NEW POINT
07600 3 CONTINUE
07700 IF(H.EQ.Y)GO TO 2
07800 C WIPES OUT THIS LINE SEG.
07900 30 IF(K.NE.Q(IX).AND.K.NE.Q(IX-1))E(IX)=1
08000 C TOUCHING END OF SEG. DOES NOT COUNT.
08100
08200 IF(H.EQ.-1000)GO TO 2
08310 CALL LINES(K,IFIX(H),J)
08320 IF(X.GT.0)CALL LINES(K,IFIX(Y),J)
08330 X=-X
08400 CC N=N+3
08500 2 CONTINUE
08600
08610 GO TO 4
11705 10 CALL DPYOUT(1)
11800 14 PAUSE
11900 GO TO 15
12000 END
12100
12200